Delphi Informant Complete 1995 - 2000/Delphi Informant Complete 1995 to 2000.iso/Delphi Informant Magazine Complete Works SOURCE CODE 1995.rar/1995/JUN/JA9506/label3d.pas

Pascal/Delphi Source File | 1995-05-04 | 6KB | 210 lines

unit Label3d;

interface

uses
  SysUtils, WinTypes, WinProcs, Controls,
  StdCtrls, Classes, Graphics, Menus;

type
  TLabelStyle = (lsRaised, lsLowered);

  TLabel3D = class(TCustomLabel)
  private
    FOffset:     integer;
    FLabelStyle: TLabelStyle;
    FAsButton:   Boolean;
    procedure SetOffset(Value: Integer);
    procedure SetLabelStyle(Value: TLabelStyle);
    procedure SetAsButton(Value: Boolean);
  protected
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton;
                        Shift: TShiftState;
                        X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState;
                        X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton;
                      Shift: TShiftState;
                      X, Y: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Offset: Integer read FOffset
                             write SetOffset default 1;
    property Align;
    property Alignment;
    property AsButton: Boolean read FAsButton
                               write SetAsButton;
    property AutoSize;
    property Caption;
    property Enabled;
    property FocusControl;
    property Font;
    property LabelStyle: TLabelStyle read FLabelStyle
                                     write SetLabelStyle;
    property ShowAccelChar;
    property ShowHint;
    property Visible;
    property WordWrap;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

constructor TLabel3D.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);  { Call TCustomLabel's Create }
  FOffset := 1;        { FOffset matches property default }
  Transparent := True;         { Transparent must be True }
  with Font do begin                { Set up default font }
    Name := 'Arial';
    Size := 12;
    Color := clBlue;
    Style := [fsBold];
  end;
end;

procedure TLabel3D.Paint;
const
  { Array that encapsulates some of
    WinProcs.DrawText's flags }
  Alignments: array[TAlignment] of Word =
   (DT_LEFT, DT_RIGHT, DT_CENTER);
var
  TempRect: TRect;
  Text: array[0..255] of Char;
  OldColor: TColor;
begin
  Canvas.Brush.Style := bsClear;   { set clear background }
  Canvas.Font := Self.Font;   { insure Canvas Font is set }
  OldColor := Font.Color;             { save font's color }
  Canvas.Font.Color := clWhite;         { make font white }
  { Create a rect that is offset for the top bevel }
  TempRect := Rect(ClientRect.Left - Offset,
                   ClientRect.Top - Offset,
                   ClientRect.Right - Offset,
                   ClientRect.Bottom - Offset);
  GetTextBuf(Text, SizeOf(Text));   { Get Label's Caption }
  { Draw offset text }
  DrawText(Canvas.Handle, Text, StrLen(Text),
           TempRect, DT_EXPANDTABS or
           DT_WORDBREAK or Alignments[Alignment]);
  Canvas.Font.Color := clBlack;     { make font white }
  { Create rect that is offset for the bottom bevel }
  TempRect := Rect(ClientRect.Left + Offset,
                   ClientRect.Top + Offset,
                   ClientRect.Right + Offset,
                   ClientRect.Bottom + Offset);
  { Draw the offset text }
  DrawText(Canvas.Handle, Text, StrLen(Text),
           TempRect, DT_EXPANDTABS or
           DT_WORDBREAK or Alignments[Alignment]);
  Canvas.Font.Color := OldColor;  { Restore the old color }
  inherited Paint;                { Call inherited Paint }
end;

procedure TLabel3D.SetOffset(Value: Integer);
begin
  if FOffset <> Value then
    begin
      FOffset := Value;
      Invalidate;
    end;
end;

procedure TLabel3D.SetLabelStyle(Value: TLabelStyle);
begin
  if FLabelStyle <> Value then begin
    { Set AsButton property to False if it is True,
      and weÆre in design mode }
    if FAsButton and
       (csDesigning in ComponentState) then
      SetAsButton(False);
      SetOffset(FOffset * -1);   { Set the FOffset field }
      FLabelStyle := Value;
    end;
end;

procedure TLabel3D.SetAsButton(Value: Boolean);
begin
  if FAsButton <> Value then begin
    if Value then
      { if label isn't already raised... }
      if LabelStyle <> lsRaised then begin
        SetLabelStyle(lsRaised);  { raise it }
      end;
    FAsButton := Value;
  end;
end;

procedure TLabel3D.MouseDown(Button: TMouseButton;
                             Shift: TShiftState;
                             X, Y: Integer);
begin
  if AsButton then
    begin
      { if it's a left mouse button and the label isn't lowered... }
      if (Button = mbLeft)         and
         (LabelStyle <> lsLowered) and
         Enabled                   then
        SetLabelStyle(lsLowered);  { set Style to Lowered }
    end
  else
    inherited MouseDown(Button, Shift, X, Y);
end;

procedure TLabel3D.MouseMove(Shift: TShiftState;
                             X, Y: Integer);
var
  NewState: TLabelStyle;
begin
  if AsButton then begin
    { If it's a left mouse button... }
    if Shift = [ssLeft] then begin
      { the cursor is within the label's client area... }
      if (X >= 0)            and
         (X < ClientWidth)   and
         (Y >= 0)            and
         (Y <= ClientHeight) then
        NewState := lsLowered   { make it Lowered }
      else
        NewState := lsRaised;   { otherwise, Raised }
      if NewState <> FLabelStyle then
        SetLabelStyle(NewState);
    end;
  end
  else
    inherited MouseMove(Shift, X, Y);
end;

procedure TLabel3D.MouseUp(Button: TMouseButton;
                           Shift: TShiftState;
                           X, Y: Integer);
begin
  if FAsButton then begin
    { The the cursor is within the label's client area... }
    if (X >= 0)            and
       (X < ClientWidth)   and
       (Y >= 0)            and
       (Y <= ClientHeight) then
      SetLabelStyle(lsRaised);  { Make it Raised }
  end
  else
    inherited MouseUp(Button, Shift, X, Y);
end;

procedure Register;
begin
  RegisterComponents('Test', [TLabel3D]);
end;

end.